home *** CD-ROM | disk | FTP | other *** search
/ CD ROM Paradise Collection 4 / CD ROM Paradise Collection 4 1995 Nov.iso / program / swagd_f.zip / EGAVGA.SWG / 0183_Improved Cross-Fade.pas < prev    next >
Pascal/Delphi Source File  |  1995-03-03  |  2KB  |  76 lines
  1. {
  2. David Proper posted a cross-fade routine here, some days ago. This is an update
  3. on that one. It now fades all texts. Quite a pain to figure this out, realy.
  4. Put it in the SWAG if you want, Kerry - Done!.
  5. }
  6. program xfade;
  7. { made by Bas van Gaalen, Holland, PD,
  8.   fido 2:285/213.8, internet bas.van.gaalen@schotman.nl }
  9. uses crt;
  10. const
  11.   vseg=$a000; fseg=$f000; fofs=$fa6e; lines=13;
  12.   creds:array[0..lines-1] of string[20]=(
  13.     {.........|.........|}
  14.     'This cross-fade',
  15.     'routine was made by',
  16.     'Bas van Gaalen',
  17.     'Code and idea',
  18.     'inspired by',
  19.     'David Proper',
  20.     'This routine was',
  21.     'enhanced a bit',
  22.     'in comparison with',
  23.     'David''s one...',
  24.     'cu later',
  25.     'alligator!',
  26.     '');
  27.  
  28. procedure setpal(c,r,g,b:byte); assembler; asm
  29.   mov dx,3c8h; mov al,[c]; out dx,al; inc dx; mov al,[r]
  30.   out dx,al; mov al,[g]; out dx,al; mov al,[b]; out dx,al; end;
  31.  
  32. procedure retrace; assembler; asm
  33.   mov dx,3dah; @vert1: in al,dx; test al,8; jz @vert1
  34.   @vert2: in al,dx; test al,8; jnz @vert2; end;
  35.  
  36. procedure cleartxt(col,new:byte);
  37. var x,y,vofs:word;
  38. begin
  39.   for x:=0 to 319 do for y:=100 to 107 do begin
  40.     vofs:=y*320+x;
  41.     if mem[vseg:vofs]=col then mem[vseg:vofs]:=0
  42.     else if mem[vseg:vofs]<>0 then mem[vseg:vofs]:=new;
  43.   end;
  44. end;
  45.  
  46. procedure writetxt(col,cur:byte; txt:string);
  47. var x,y,vofs:word; i,j,k:byte;
  48. begin
  49.   x:=(320-8*length(txt)) div 2; y:=100;
  50.   for i:=1 to length(txt) do for j:=0 to 7 do for k:=0 to 7 do
  51.     if ((mem[fseg:fofs+ord(txt[i])*8+j] shl k) and 128) <> 0 then begin
  52.       vofs:=(y+j)*320+(i*8)+x+k;
  53.       if mem[vseg:vofs]=cur then mem[vseg:vofs]:=col+cur else
  54. mem[vseg:vofs]:=col;    end;
  55. end;
  56.  
  57. var txtidx,curcol,i:byte;
  58. begin
  59.   asm mov ax,13h; int 10h; end;
  60.   setpal(1,0,0,0); setpal(2,0,0,0); setpal(3,63 div 2,63,63 div 2);
  61.   curcol:=1; txtidx:=0;
  62.   repeat
  63.     cleartxt(curcol,3-curcol);
  64.     writetxt(curcol,3-curcol,creds[txtidx]);
  65.     for i:=0 to 63 do begin
  66.       retrace;
  67.       setpal(curcol,i div 2,i,i div 2);
  68.       setpal(3-curcol,(63-i) div 2,63-i,(63-i) div 2);
  69.     end;
  70.     delay(500);
  71.     curcol:=1+(curcol mod 2);
  72.     txtidx:=(1+txtidx) mod lines;
  73.   until keypressed;
  74.   textmode(lastmode);
  75. end.
  76.